Prep preamble

Introduction/structure

The analyses promised are the following, in the following order:

Annual change rates in life expectancy in the UK as compared with a number of other high income countries.
Annual change rates in life expectancy in the UK as a whole and UK nations or groups of nations + change point analyses 2a. Life expectancy change rates 2b. Changepoint analysis
ONS life expectancy projections from 2012 onwards, to show how these have been successively downrated with each biennial projection
Bayes Factors for \(e_0\) changes since 2010 assuming different rates of slowdown expressed as a % of average prior change
Average improvment rates for \(e_0\) implied by each ONS projection, to quantify how optimistic/pessimistic each of the projections has been compared with post 2010 trends

Let’s reorganise this material to better reflect the proposed order in the paper.

1 Annual rates of change internationally

1.1 Data

The data used were \(e_0\) from the Human Mortality Database.

The data were extracted using the HMDHFDplus package.

1.2 Results

The above should just be done once. Once extracted and saved, it should be loaded

## Parsed with column specification:
## cols(
##   country = col_character(),
##   year = col_double(),
##   sex = col_character(),
##   e0 = col_double()
## )

Let’s label the countries and pick out only mutually exclusive populations. The code lookups are here

code_lookup <- tribble(
  ~code,    ~label,                      ~include, 
  "AUS",     "Australia",                  1, 
  "AUT",     "Austria",                    1, 
  "BLR",     "Belarus",                    1,
  "BEL",     "Belgium",                    1, 
  "BGR",     "Bulgaria",                   1,
  "CAN",     "Canada",                     1,
  "CHL",     "Chile",                      1,
  "HRV",     "Croatia",                    1,
  "CZE",     "Czechia",                    1,
  "DNK",     "Denmark",                    1,
  "EST",     "Estonia",                    1,
  "FIN",     "Finland",                    1, 
  "FRATNP",  "France",                     1,
  "FRACNP",  "France (Civilian)",          0,
  "DEUTNP",  "Germany",                    1,
  "DEUTW",   "Germany (West)",             0,
  "DEUTE",   "Germany (East)",             0,
  "GRC",     "Greece",                     1,
  "HUN",     "Hungary",                    1,
  "ISL",     "Iceland",                    1,
  "IRL",     "Ireland",                    1,
  "ISR",     "Israel",                     1, 
  "ITA",     "Italy",                      1,
  "JPN",     "Japan",                      1,
  "KOR",     "South Korea",                1,
  "LVA",     "Latvia",                     1,
  "LTU",     "Lithuania",                  1, 
  "LUX",     "Luxembourg",                 1,
  "NLD",     "Netherlands",                1,
  "NZL_NP",  "New Zealand",                1,
  "NZL_MA",  "New Zealand (Maori)",        0,
  "NZL_NM",  "New Zealand (Non-Maori)",    0,
  "NOR",     "Norway",                     1,
  "POL",     "Poland",                     1,
  "PRT",     "Portugal",                   1,
  "RUS",     "Russia",                     1,
  "SVK",     "Slovakia",                   1,
  "SVN",     "Slovenia",                   1, 
  "ESP",     "Spain",                      1, 
  "SWE",     "Sweden",                     1, 
  "CHE",     "Switzerland",                1, 
  "TWN",     "Taiwan",                     1,
  "GBR_NP",  "United Kingdom",             1, 
  "GBRTENW", "England & Wales (Total)",    0,
  "GRBCENW", "England & Wales (Civilian)", 0,
  "GBR_SCO", "Scotland",                   0,
  "GBR_NIR", "Northern Ireland",           0,
  "USA",     "USA",                        1,
  "UKR",     "Ukraine",                    1
)

#Are any codes not matched?
hmd_e0 %>% 
  left_join(code_lookup, by = c("country" = "code")) %>% 
  count(label)

# 49 rows so fine

# What's the first year for each country? 
hmd_e0 %>% 
  left_join(code_lookup, by = c("country" = "code")) %>% 
  group_by(label) %>% 
  summarise(
    min_year = min(year),
    max_year = max(year)
  ) %>% 
  arrange(desc(min_year))

# South Korea: 2003 onwards
# Croatia: 2002 onwards
# Chile: 1992 onwards 
# All others at least since 1990

For all mutually exclusive countries in the HMD with data since 1990 onwards, the following shows how annual life expectancy has changed over time

1.2.1 HMD Average change in \(e_0\) by decade

1.2.1.1 Figure of HMD Average change in \(e_0\) by decade

## Joining, by = c("label", "sex")

1.2.1.2 Table of HMD Average change in \(e_0\) by decade

mean_ch_e0_decade_hmd <- 
  ch_e0_from1990_hmd %>% 
    filter(!is.na(ch_e0)) %>% 
    mutate(
      decade = case_when(
        between(year, 1990, 1999)      ~ "1990s",
        between(year, 2000, 2009)      ~ "2000s",
        between(year, 2010, 2020)      ~ "2010s",
        TRUE                           ~ NA_character_
      )
    ) %>% 
    group_by(label, sex, decade) %>% 
    summarise(mean_ch_e0 = mean(ch_e0, na.rm = TRUE)) %>% 
    ungroup() 


mean_ch_e0_decade_hmd %>% 
  left_join(
    mean_ch_e0_decade_hmd %>% filter(decade == "2010s") %>% 
      mutate(ch_last = mean_ch_e0) %>% 
      select(-mean_ch_e0, -decade) 
  ) %>% 
  mutate(decade = fct_rev(decade)) %>% 
  arrange(desc(ch_last)) %>% 
  select(-ch_last) %>% 
  unite(col = "sex_decade", sex, decade) %>%
  rename(Country = label) %>% 
  mutate(mean_ch_e0 = round(mean_ch_e0, 3)) %>% 
  spread(sex_decade, mean_ch_e0) %>%
  set_names(nm = c("Country", rep(c("1990s", "2000s", "2010s"), 2))) %>% 
  kable() %>% 
  kable_styling() %>% 
  add_header_above(c(" ", "Female" = 3, "Male" = 3)) %>% 
  footnote(general = "Average annual change in life expectancy by decade, sex, and country")

## Joining, by = c("label", "sex")

	Female			Male
Country	1990s	2000s	2010s	1990s	2000s	2010s
Australia	0.267	0.199	0.127	0.339	0.299	0.191
Austria	0.217	0.202	0.130	0.288	0.262	0.235
Belarus	-0.242	0.245	0.379	-0.454	0.248	0.613
Belgium	0.195	0.157	0.139	0.205	0.279	0.229
Bulgaria	0.019	0.223	0.126	-0.009	0.197	0.150
Canada	0.118	0.169	0.131	0.225	0.270	0.176
Czechia	0.265	0.222	0.195	0.321	0.283	0.231
Denmark	0.113	0.215	0.250	0.222	0.263	0.301
Estonia	0.123	0.392	0.281	-0.052	0.481	0.460
Finland	0.213	0.208	0.136	0.287	0.274	0.274
France	0.185	0.190	0.109	0.249	0.281	0.211
Germany	0.259	0.173	0.101	0.297	0.266	0.165
Greece	0.149	0.216	0.122	0.109	0.193	0.240
Hungary	0.178	0.263	0.143	0.143	0.345	0.305
Iceland	0.127	0.223	0.040	0.133	0.222	0.091
Ireland	0.155	0.355	0.166	0.169	0.423	0.305
Israel	0.220	0.272	0.134	0.181	0.303	0.147
Italy	0.205	0.199	0.192	0.247	0.311	0.276
Japan	0.212	0.244	0.119	0.121	0.236	0.199
Latvia	-0.013	0.263	0.242	-0.114	0.332	0.286
Lithuania	0.073	0.160	0.229	-0.051	0.079	0.447
Luxembourg	0.275	0.220	0.123	0.306	0.386	0.180
Netherlands	0.053	0.221	0.067	0.167	0.321	0.191
New Zealand	0.238	0.215	0.228	0.357	0.320	0.302
Norway	0.128	0.194	0.157	0.228	0.298	0.268
Poland	0.223	0.253	0.251	0.217	0.298	0.319
Portugal	0.171	0.288	0.212	0.163	0.374	0.258
Russia	-0.207	0.236	0.340	-0.433	0.298	0.482
Slovakia	0.181	0.186	0.201	0.204	0.254	0.296
Slovenia	0.203	0.301	0.175	0.249	0.402	0.291
Spain	0.194	0.221	0.163	0.199	0.314	0.239
Sweden	0.133	0.144	0.099	0.229	0.227	0.174
Switzerland	0.154	0.171	0.150	0.272	0.285	0.271
Taiwan	0.216	0.335	0.170	0.173	0.292	0.138
Ukraine	-0.158	0.124	0.338	-0.352	0.174	0.490
United Kingdom	0.168	0.244	0.091	0.229	0.316	0.164
USA	0.079	0.165	0.047	0.232	0.217	0.029
Note:
Average annual change in life expectancy by decade, sex, and country

The countries with the fastest average improvement in \(e_0\) in the 2010s include Belarus (0.38 years/year for females, 0.61 years/year for males), Ukraine (0.34 females, 0.49 males), Russia (0.34 females, 0.48 males), Lithuania (0.23 females, 0.45 males), and Poland (0.25 females, 0.32 males). By contrast, the countries with the slowest improvements in the 2010s include the USA (0.05 females, 0.03 males), Iceland (0.04 females, 0.09 males), the United Kingdom (0.09 females, 0.16 males), Netherlands (0.07 females, 0.19 males), and Germany (0.10 females, 0.17 males). With the exception of the USA, there is still a tendency for improvements in the 2010s to be somewhat faster for males than females. The fastest-improving countries also tended to experience the slowest rates of improvement, or severe deteriorations (worsenings), in life expectancy change in the 1990s.

The similarity between average rates of improvement in the 2010s in Germany and the UK is noteworthy with average sex specific improvement rates within 0.01 years per year of each other (0.09 compared with 0.10 for females in the UK and Germany respectively; 0.16 compared with 0.17 for males). The German data covers 2010-2017 inclusive, whereas for the UK the data extends to 2016.

1.2.1.3 Annual change in slow gainers since 1990

There are some important differences, however, in how annual change rates have varied in the the slowest-improving countries. Figure X shows this for the five slowest-improving countries excluding Iceland, which due to its small population size shows much greater levels of annual variability than the other countries. From this figure it is apparent that the USA not only tended to show lower rates of improvement before 2010, but has also been exhibiting continuing and more persistent declines than the other countries, with three consecutive years of declining mortality for males in the last three available years, and only modest improvements for females.

2 Annual change rates in life expectancy in the UK as a whole and UK nations or groups of nations + change point analyses

The previous section used data from the HMD, comparing the UK as a whole against other countries in the HMD. The last year available for the UK in the HMD was 2016. More recent \(e_0\) estimates are available from the ONS, which also provides estimates disaggregated by country and group of countries within the UK. We will use this data to explore how (dis)similar the trends in life expectancy change have been within different UK nations/groups of nations.

2.1 Data

We’ll now use the tables from this location to get \(e_0\), \(m_x\) and related lifetable quantities from a single source, for each UK nation.

First, I’ve downloaded each of the single year files to the data directory.

2.1.1 Data preparation

The following code will not be run, as the data have already been extracted. However it is kept here for completeness.

First, defining the files to extract lifetables from.

Then, defining a function to clean the data from the worksheets in the workbooks.

Now, getting the \(m_x\) data.

Now, extracting the lifetables in a tidy format.

From this it’s very easy to extract \(e_0\) alone.

To save on this, let’s just load the tidied \(e_0\) data

dta_e0 <- read_csv(here("data", "e0_from_ons_allnations.csv"))

## Parsed with column specification:
## cols(
##   population = col_character(),
##   year = col_double(),
##   sex = col_character(),
##   e0 = col_double()
## )

dta_e0

2.2 Analysis

2.2.1 Change in life expectancy in UK nations and groups of nations

2.2.1.1 Figure of change in life expectancy in UK nations and groups of nations

Visualise the life expectancy and change in life expectancy for each year

## `geom_smooth()` using method = 'loess' and formula 'y ~ x'

## `geom_smooth()` using method = 'loess' and formula 'y ~ x'

From the above it seems most populations have seen a slowdown in improvement in recent years, and on average relatively stable improvements previously, with the exception of Northern Ireland, which saw a slowdown in improvement in the 1980s. The smaller populations tend to exhibit greater variability in annual rates of change than the larger populations. The extent of oscillation (negative autocorrelation from one year to the next) also appears greater in smaller populations. It is not immediately clear that the breakpoint for the slowdown is the same for all UK populations.

2.2.2 Average change by decade

As before, let’s look at the average improvement per decade. This will allow us to compare the UK rates from the ONS against those in the HMD.

ons_ch_e0_decade <- 
  dta_e0 %>% 
    group_by(population, sex) %>% 
    arrange(year) %>% 
    mutate(ch_e0 = e0 - lag(e0)) %>% 
    ungroup() %>% 
    mutate(
      population = fct_relevel(population, c("United Kingdom", "Great Britain", "England & Wales", "England", "Scotland", "Wales", "Northern Ireland"))
    ) %>% 
    filter(!is.na(ch_e0)) %>% 
    select(-e0) %>% 
    mutate(
        decade = case_when(
          between(year, 1980, 1989)      ~ "1980s",
          between(year, 1990, 1999)      ~ "1990s",
          between(year, 2000, 2009)      ~ "2000s",
          between(year, 2010, 2020)      ~ "2010s",
          TRUE                           ~ NA_character_
      )
    ) %>% 
    group_by(population, sex, decade) %>% 
    summarise(mean_ch_e0 = mean(ch_e0, na.rm = TRUE)) %>% 
    ungroup() 

ons_ch_e0_decade

As expected, the ONS and HMD estimates of mean improvement per decade are closely aligned, usually within two decimal places, though are somewhat lower in the 2010s for ONS than for HMD:

sex	decade	HMD	ONS
f	90s	0.168	0.170
f	00s	0.244	0.241
f	10s	0.091	0.080
m	90s	0.229	0.232
m	00s	0.319	0.313
m	10s	0.164	0.131

Let’s now present this as a barplot

ons_ch_e0_decade %>% 
  filter(population %in% c("United Kingdom", "Wales", "Scotland", "England", "Northern Ireland")) %>% 
  left_join(
    ons_ch_e0_decade %>% filter(decade == "2010s") %>% 
      mutate(ch_last = mean_ch_e0) %>% 
      select(-mean_ch_e0, -decade) 
  ) %>% 
  mutate(decade = fct_rev(decade)) %>% 
  ggplot(aes(x = population, y = mean_ch_e0, group = decade, colour = decade, fill = decade)) + 
  geom_col(position = "dodge") + 
  facet_wrap(~sex) + 
  coord_flip() + 
  scale_fill_grey("Decade", guide = guide_legend(reverse = TRUE)) + 
  scale_colour_grey("Decade", guide = guide_legend(reverse = TRUE)) + 
  labs(
    x = "Country", y = "Mean annual life expectancy change in years",
    title = "Mean annual change in life expectancy in UK nations, by sex and decade",
    
    caption = "Source: Office for National Statistics"
  )

## Joining, by = c("population", "sex")

ggsave(here("figures", "mean_ch_e0_decade_uknations.png"), height = 20, width = 30, units = "cm", dpi = 300)

For each UK nation, the 2000s had exceptionally high rates of improvement. By contrast the 2010s are exceptionally low. Within Northern Ireland, there was an exceptionally high rate of improvement in the 1980s. Rates of improvement in the 2000s have been higher in the 2000s in males than females.

2.2.3 Change in life expectancy in mutually exclusive UK nations

2.2.3.1 Change in life expectancy in mutually exclusive UK nations - faceted

## `geom_smooth()` using method = 'loess' and formula 'y ~ x'

## `geom_smooth()` using method = 'loess' and formula 'y ~ x'

2.2.3.2 Change in life expectancy in mutually exclusive UK nations - overlaid

There are clear similarities between the trends in each of the UK nations, again with the exception of Northern Ireland. The trends even seem to correspond in terms of which years are ‘good years’ and which years are ‘bad years’ (i.e. they oscillate in phase with each other). To check this let’s look at the correlation between the trends

corrs_trends <- 
  dta_e0 %>% 
    filter(population %in% c("England", "Wales", "Scotland", "Northern Ireland")) %>% 
    group_by(population, sex) %>% 
    arrange(year) %>% 
    mutate(ch_e0 = e0 - lag(e0)) %>% 
    ungroup() %>% 
    filter(!is.na(ch_e0)) %>% 
    select(-e0) %>% 
    unite(col = "pop_sex", population, sex) %>% 
    spread(pop_sex, ch_e0) %>% 
    select(-year) %>% 
    correlate()

## 
## Correlation method: 'pearson'
## Missing treated using: 'pairwise.complete.obs'

corrs_trends

corrs_trends %>% 
  rplot() +
  theme(axis.text.x = element_text(angle = 45, hjust = 1))

## Don't know how to automatically pick scale for object of type noquote. Defaulting to continuous.

corrs_trends %>% 
  network_plot()

Trends in males and females in England are highly correlated (r = 0.89). The correlation between male and female trends in Wales are also strong (r = 0.77), which is slightly below the correlation between females in England and Wales (r = 0.81). Correlations between males and females in Scotland are slightly weaker (r = 0.67), and the associations between sexes are weakest in Northern Ireland (r = 0.55).

The network plot places series that are more correlated with each other closer together, and less correlated series further from each other. This confirms that males’ and females’ trends are closely correlated to each other in England and Wales, somewhat less so in Scotland, and least in Northern Ireland, where trends between sexes are less correlated with each other than are the correlations between countries elsewhere in the UK.

This suggests that any general trends which apply throughout the UK will apply less strongly in Northern Ireland than elsewhere. This should be considered when looking at the results in the next section, which aims to identify if and when there have been breakpoints in the trends in UK nations.

2.2.4 Breakpoint analysis

The following section will perform breakpoint analysis using the segmented package for each UK nation as well as the UK as a whole.

First we look to see if two and three breakpoints can be identified in any of the populations.

datablocks <- 
  dta_e0 %>% 
    group_by(population, sex) %>% 
    arrange(year) %>% 
    mutate(ch_e0 = e0 - lag(e0)) %>% 
    ungroup() %>% 
    filter(!is.na(ch_e0)) %>% 
    select(-e0) %>% 
    group_by(population, sex) %>% 
    nest() 



segmods_1brk <- vector(mode = "list", length = 14)
segmods_2brk <- vector(mode = "list", length = 14)
segmods_3brk <- vector(mode = "list", length = 14)

for (i in 1:14){
  this_data <- datablocks[["data"]][[i]]
  
  this_linmod <- lm(ch_e0 ~ year, data = this_data)
  
  this_segmod_1brk <- tryCatch(segmented(this_linmod, npsi = 1, control = seg.control(seed = 1)), finally = NULL)
  this_segmod_2brk <- tryCatch(segmented(this_linmod, npsi = 2, control = seg.control(seed = 1)), finally = NULL)
  this_segmod_3brk <- tryCatch(segmented(this_linmod, npsi = 3, control = seg.control(seed = 1)), finally = NULL)
  
  segmods_1brk[[i]] <- this_segmod_1brk
  segmods_2brk[[i]] <- this_segmod_2brk
  segmods_3brk[[i]] <- this_segmod_3brk
  
}

# segmented::segmented()

In many cases, breakpoints cannot be identified. However this may be if multiple breakpoints are being attempted, but not all can be estimated. We are mainly interested in whether there’s been a single breakpoint, and whether this has been identified consistently in all populations.

To investigate this, let’s explore whether the same single breakpoint can be consistently identified. We can do that by checking whether the choice of random number seed matters.

segmods1brk_seed01 <- vector(mode = "list", length = 14)
segmods1brk_seed02 <- vector(mode = "list", length = 14)
segmods1brk_seed03 <- vector(mode = "list", length = 14)
segmods1brk_seed06 <- vector(mode = "list", length = 14)
segmods1brk_seed08 <- vector(mode = "list", length = 14)


for (i in 1:14){
  this_data <- datablocks[["data"]][[i]]
  
  this_linmod <- lm(ch_e0 ~ year, data = this_data)
  
  segmods1brk_seed01[[i]] <- tryCatch(segmented(this_linmod, npsi = 1, control = seg.control(seed = 1)), finally = NULL)
  segmods1brk_seed02[[i]] <- tryCatch(segmented(this_linmod, npsi = 1, control = seg.control(seed = 2)), finally = NULL)
  segmods1brk_seed03[[i]] <- tryCatch(segmented(this_linmod, npsi = 1, control = seg.control(seed = 3)), finally = NULL)
  segmods1brk_seed06[[i]] <- tryCatch(segmented(this_linmod, npsi = 1, control = seg.control(seed = 6)), finally = NULL)
  segmods1brk_seed08[[i]] <- tryCatch(segmented(this_linmod, npsi = 1, control = seg.control(seed = 8)), finally = NULL)
  

}

Note that consecutive random numbers cannot be used, as for some random numbers (4, 5 and 7 in this case) breakpoints cannot be identified.

Let’s pull the 1 breakpoint estimates

get_brks <- function(x){
  tryCatch(summary(x)$psi[,2], finally = NULL)
}

datablocks %>% 
  ungroup() %>% 
  mutate(
    segmod_1brk  = segmods_1brk,
    segmod_2brk = segmods_2brk,
    segmod_3brk = segmods_3brk
  ) %>% 
  mutate(
    brks_1 = map_dbl(segmod_1brk, get_brks),
    brks_2 = map(segmod_2brk, get_brks),
    brks_3 = map(segmod_3brk, get_brks)
  )

This shows that 1 breakpoint models can be identified for each population, but 2 and 3 breakpoint models only for some populations. For almost all populations, except Northern Ireland, the breakpoint is identified as around 2009 (so the change from 2009 to 2010)

2.2.4.1 Breakpoint figure

The following shows the breakpoints and standard errors.

datablocks %>% 
  ungroup() %>% 
  mutate(
    segmod_1brk  = segmods_1brk
  ) %>% 
  mutate(
    brk_year = map_dbl(segmod_1brk, ~summary(.x)$psi[2]),
    brk_se   = map_dbl(segmod_1brk, ~summary(.x)$psi[3])
  ) %>% 
  select(population, sex, brk_year, brk_se) %>% 
  mutate(
    brk_lwr = brk_year - 2 * brk_se, 
    brk_upr = brk_year + 2 * brk_se
  ) %>% 
  mutate(
    population = fct_relevel(population, rev(c("United Kingdom", "Great Britain", "England & Wales", "England", "Scotland", "Wales", "Northern Ireland")))
  ) %>% 
  ggplot(aes(x = brk_year, y = population)) + 
  geom_point() + 
  geom_errorbarh(aes(xmin = brk_lwr, xmax=brk_upr), height = 0.2) + 
  facet_wrap(~sex) + 
  geom_vline(xintercept = 2018) + 
  labs(
    x = "Year", 
    y = "Population",
    title = "Estimates of breakpoint years from one breakpoint models",
    subtitle = "Error bars show two standard errors around estimate",
    caption = "Source: ONS Single Year Lifetables"
  
  ) + 
  theme_light()

ggsave(here("figures", "breakpoint_uk_allgroups.png"), height = 15, width = 25, units = "cm", dpi = 300)

2.2.4.2 Breakpoint table

This shows a lot of consistency in estimates of when the breakdown occurred. With the exception of Northern Ireland, we can use 2010 afterwards as ‘post-slowdown’, and the years from 1980 onwards as ‘pre-slowdown’.

datablocks %>% 
  ungroup() %>% 
  mutate(
    segmod_1brk  = segmods_1brk
  ) %>% 
  mutate(
    brk_year = map_dbl(segmod_1brk, ~summary(.x)$psi[2]),
    brk_se   = map_dbl(segmod_1brk, ~summary(.x)$psi[3])
  ) %>% 
  select(population, sex, brk_year, brk_se) %>% 
  mutate(
    brk_lwr = brk_year - 2 * brk_se, 
    brk_upr = brk_year + 2 * brk_se
  ) %>% 
  mutate(
    population = fct_relevel(population, rev(c("United Kingdom", "Great Britain", "England & Wales", "England", "Scotland", "Wales", "Northern Ireland")))
  ) %>% 
  rename(
    Population = population,
    Sex = sex, 
    Breakpoint = brk_year, 
    SE         = brk_se,
    `Lower CI` = brk_lwr, `Upper CI` = brk_upr
  ) %>% 
  mutate_if(is.numeric, ~round(., 2)) %>% 
  kable() %>% 
  kable_styling()

Population	Sex	Breakpoint	SE	Lower CI	Upper CI
England	female	2009.00	5.15	1998.70	2019.30
England	male	2009.93	2.34	2005.26	2014.60
Northern Ireland	female	1985.00	5.13	1974.73	1995.27
Northern Ireland	male	1983.00	1.92	1979.16	1986.84
Scotland	female	2009.87	4.95	1999.97	2019.77
Scotland	male	2010.45	3.05	2004.36	2016.54
Wales	female	2009.00	6.80	1995.40	2022.60
Wales	male	2010.00	4.43	2001.14	2018.86
England & Wales	female	2009.00	5.25	1998.49	2019.51
England & Wales	male	2009.92	2.35	2005.22	2014.63
Great Britain	female	2009.00	5.26	1998.48	2019.52
Great Britain	male	2009.98	2.29	2005.41	2014.56
United Kingdom	female	2009.00	5.35	1998.30	2019.70
United Kingdom	male	2009.95	2.39	2005.18	2014.72

2.2.4.3 Breakpoint figure - mutually exclusive UK nations

The following shows the breakpoints and standard errors.

2.2.4.2 Breakpoint table

Population	Sex	Breakpoint	SE	Lower CI	Upper CI
England	female	2009.00	5.15	1998.70	2019.30
England	male	2009.93	2.34	2005.26	2014.60
Northern Ireland	female	1985.00	5.13	1974.73	1995.27
Northern Ireland	male	1983.00	1.92	1979.16	1986.84
Scotland	female	2009.87	4.95	1999.97	2019.77
Scotland	male	2010.45	3.05	2004.36	2016.54
Wales	female	2009.00	6.80	1995.40	2022.60
Wales	male	2010.00	4.43	2001.14	2018.86
England & Wales	female	2009.00	5.25	1998.49	2019.51
England & Wales	male	2009.92	2.35	2005.22	2014.63
Great Britain	female	2009.00	5.26	1998.48	2019.52
Great Britain	male	2009.98	2.29	2005.41	2014.56
United Kingdom	female	2009.00	5.35	1998.30	2019.70
United Kingdom	male	2009.95	2.39	2005.18	2014.72

2.2.4.2 Effect of different random number seeds on breakpoint

Let’s do the same for the five one breakpoint models using different seeds

Break point years, where they can be calculated, are largely identical. They confirm 2010 as a reasonable breakpoint year except for Northern Ireland.

ONS life expectancy projections from 2012 onwards, to show how these have been successively downrated with each biennial projection

3 ONS life expectancy projections

The ONS modifies their estimates of life expectancy every couple of years as part of their population projections exercise. For the last four projections the life expectancy projections have been downgraded. This section will show how projections have changed over time, and how they compare against observed life expectancy.

3.1 Data

For Scotland, the data for the projections are made available at this location on the ONS website:

The specific projections are available at the following locations:

For England, the projections are available here.

For Wales, the projections are available here.

For Northern Ireland, the projections are available here

The for United Kingdom, the projections are available here

proj_2018_males <- read_excel(path = here("data", "ons_projections", "scotland", "scppp18ex.xls"),
                        sheet = "Males period ex", skip = 9
                          
                          ) %>% slice(-1) 
proj_2018_females <- read_excel(path = here("data", "ons_projections", "scotland", "scppp18ex.xls"),
                        sheet = "Females period ex", skip = 9
                          
                          ) %>% slice(-1) 

proj_2016_males <- read_excel(path = here("data", "ons_projections", "scotland", "wscoprincipal16.xls"),
                        sheet = "Males period ex", skip = 9
                          
                          ) %>% slice(-1) 
proj_2016_females <- read_excel(path = here("data", "ons_projections", "scotland", "wscoprincipal16.xls"),
                        sheet = "Females period ex", skip = 9
                          
                          ) %>% slice(-1) 

proj_2014_males <- read_excel(path = here("data", "ons_projections", "scotland", "wscoprincipal14.xls"),
                        sheet = "Males period ex", skip = 9
                          
                          ) %>% slice(-1) 
proj_2014_females <- read_excel(path = here("data", "ons_projections", "scotland", "wscoprincipal14.xls"),
                        sheet = "Females period ex", skip = 9
                          
                          ) %>% slice(-1) 

proj_2012_males <- read_excel(path = here("data", "ons_projections", "scotland", "wscoprincipal12exr.xls"),
                        sheet = "Males Period ex", skip = 10
                          
                          ) %>% slice(-1) 
proj_2012_females <- read_excel(path = here("data", "ons_projections", "scotland", "wscoprincipal12exr.xls"),
                        sheet = "Females Period ex", skip = 10
                          
                          ) %>% slice(-1)

Now tidying, gathering, and combining

all_projections <- bind_rows(
proj_2012_females %>% 
  rename(age = `(years)`) %>% 
  gather(-age, key = "year", value = "ex") %>% 
  mutate(sex = "female", projection = "2012 projection"),
proj_2012_males %>% 
  rename(age = `(years)`) %>% 
  gather(-age, key = "year", value = "ex") %>% 
  mutate(sex = "male", projection = "2012 projection"),
proj_2014_males %>% 
  rename(age = `Attained age (years)`) %>% 
  gather(-age, key = "year", value = "ex") %>% 
  mutate(sex = "male", projection = "2014 projection"),
proj_2014_females %>% 
  rename(age = `Attained age (years)`) %>% 
  gather(-age, key = "year", value = "ex") %>% 
  mutate(sex = "female", projection = "2014 projection"),
proj_2016_males %>% 
  rename(age = `Attained age (years)`) %>% 
  gather(-age, key = "year", value = "ex") %>% 
  mutate(sex = "male", projection = "2016 projection"),
proj_2016_females %>% 
  rename(age = `Attained age (years)`) %>% 
  gather(-age, key = "year", value = "ex") %>% 
  mutate(sex = "female", projection = "2016 projection"),
proj_2018_males %>% 
  rename(age = `Attained age (years)`) %>% 
  gather(-age, key = "year", value = "ex") %>% 
  mutate(sex = "male", projection = "2018 projection"),
proj_2018_females %>% 
  rename(age = `Attained age (years)`) %>% 
  gather(-age, key = "year", value = "ex") %>% 
  mutate(sex = "female", projection = "2018 projection")
) %>% 
  mutate(year = as.numeric(year))
all_projections

Now to visualise

all_projections %>% 
  filter(age == 0) %>% 
  filter(year >= 2010) %>% 
  ggplot(aes(x = year, y = ex, colour = projection, group = projection)) +
  geom_line() + 
  facet_wrap(~sex)

And now conditional

all_projections %>% 
  filter(year >= 2010) %>% 
  ggplot(aes(x = year, age, fill = ex)) + 
  geom_tile() + 
  facet_grid(sex ~ projection) +
  scale_fill_distiller(palette = "Paired")

And now differences between two consecutive projections

all_projections %>% 
  spread(projection, ex) %>% 
  mutate(
    `2012-2014` = `2014 projection` - `2012 projection`,
    `2014-2016` = `2016 projection` - `2014 projection`,
    `2016-2018` = `2018 projection` - `2016 projection`
  ) %>% 
  select(age, year, sex, `2012-2014`:`2016-2018`) %>% 
  gather(key = "Comparison", value= "ch_ex", `2012-2014`:`2016-2018`) %>% 
  filter(year >= 2010) %>% 
  ggplot(aes(x = year, age, fill = ch_ex)) + 
  geom_tile() + 
  facet_grid(sex ~ Comparison) +
  scale_fill_distiller(palette = "RdBu", limits = c(-1.5, 1.5))

I want to check the % change is as expected

all_projections %>% 
  filter(age == 0) %>% 
  filter(projection == "2018 projection") %>% 
  group_by(sex) %>% arrange(year) %>% 
  mutate(r_e0 = (ex - lag(ex)) / lag(ex)) %>% 
  filter(year >= 2020) %>% 
  ggplot(aes(x = year, y = r_e0, colour = sex, group = sex)) + 
  geom_line()

all_projections %>% 
  filter(age == 0) %>% 
  filter(projection == "2018 projection") %>% 
  group_by(sex) %>% arrange(year) %>% 
  mutate(d_e0 = ex - lag(ex)) %>% 
  filter(year >= 2020) %>% 
  ggplot(aes(x = year, y = d_e0, colour = sex, group = sex)) + 
  geom_line()

===========

Now, let’s determine the average change (and SD) from 1980 to 2010

dta_e0 %>% 
  group_by(population, sex) %>% 
  arrange(year) %>% 
  mutate(ch_e0 = e0 - lag(e0)) %>% 
  ungroup() %>% 
  filter(!is.na(ch_e0)) %>%
  filter(year < 2010) %>% 
  select(-e0) %>% 
  group_by(population, sex) %>% 
  arrange(year) %>% 
  summarise(
    mean_ch = mean(ch_e0),
    sd_ch   = sd(ch_e0)   
  ) %>% 
  write_to_table(here("data", "mean_sd_ch_preslowdown_ons.csv")) %>% 
  mutate(mean_ch = mean_ch * 52.25, sd_ch = sd_ch * 52.25) %>% 
  ggplot(aes(x = mean_ch, y = sd_ch, shape = sex, colour = sex)) + 
  geom_point() + 
  geom_text_repel(aes(label = population, colour = sex), show.legend = FALSE) + 
  labs(
    x = "Mean annual change in life expectancy in weeks",
    y = "Standard deviation in annual change in life expectancy in weeks", 
    title = "Mean and standard deviation of change in life expectancy\nfrom 1980 to 2010 by UK population",
    caption = "Source: ONS Single Year Lifetables"
  ) +
  

ggsave(here("figures", "mean_sd_preslowdown_improvement_ons.png"), height = 20, width = 20, units = "cm", dpi = 300)

For each of these populations, we can estimate the relative likelihood of observing the observed life expectancies from 2011 onwards under the assumption that each population’s fundamentals of life expectancy improvement had not changed after 2010. This assumption is questionable for Northern Ireland because of its changepoint in the mid 1980s, but will be applied to this population too for consistency with the other populations.

bf_uk_nations <- 
  dta_e0 %>% 
    group_by(population, sex) %>% 
    arrange(year) %>% 
    mutate(ch_e0 = e0 - lag(e0)) %>% 
    ungroup() %>% 
    filter(!is.na(ch_e0)) %>%
    select(-e0) %>% 
    group_by(population, sex) %>% 
    arrange(year) %>% 
    nest() %>% 
    crossing(after_end = 2011:2018) %>% 
    mutate(
      bayes_df = map2(
        after_end, data, ~calc_bayes_factors(after_period = c(2011, .x), before_period = c(1981, 2010), outcome_var = ch_e0, dta = .y)
      )
    ) %>% 
    select(population, sex, after_end, bayes_df) %>% 
    unnest(cols = c(bayes_df)) %>% 
    mutate(
      period = paste0("2011-", str_sub(after_end, 3,4))
    ) 

bf_uk_nations

bf_uk_nations %>% 
  mutate(perc = 100 * perc) %>% 
  mutate(
    population = fct_relevel(population, c("United Kingdom", "Great Britain", "England & Wales", "England", "Scotland", "Wales", "Northern Ireland"))
  ) %>% 
  ggplot(aes(x = perc, y = bayes_factor, alpha = period)) +
  geom_line() + 
  geom_line(aes(x = perc, y = bayes_factor), size = 1.4, 
              data = bf_uk_nations %>% 
                filter(period == "2011-18") %>% 
                mutate(perc = 100 * perc) %>%
                mutate(
    population = fct_relevel(population, c("United Kingdom", "Great Britain", "England & Wales", "England", "Scotland", "Wales", "Northern Ireland"))
  ) %>% 
                mutate(is_pos = bayes_factor > 1),
              inherit.aes = FALSE
            ) + 
  facet_wrap(population ~ sex, scales = "free_y") +
  geom_ribbon(aes(
      ymin = ifelse(is_pos, 1, bayes_factor), 
      ymax = ifelse(is_pos, bayes_factor, 1), 
      x = perc, group = paste0(is_pos, period),
      fill = is_pos
    ), 
              data = bf_uk_nations %>% 
                mutate(perc = 100 * perc) %>%
                  mutate(
              population = fct_relevel(population, c("United Kingdom", "Great Britain", "England & Wales", "England", "Scotland", "Wales", "Northern Ireland"))
            ) %>% 
                mutate(is_pos = bayes_factor > 1),
              inherit.aes = FALSE, alpha = 0.2) + 
  # scale_y_continuous(limits = c(0.999, 1.008), 
  #                    breaks = seq(0.999, 1.0080, by = 0.001)
  #                      
  #                      ) +
  scale_alpha_discrete("Period", range = c(0.2, 1), breaks = c("2011-11", "2011-12", "2011-13", "2011-14", "2011-15", "2011-16", "2011-17", "2011-18")) +
  geom_hline(yintercept = 1) + 
  labs(
    x = "Percentage of previous improvement",
    y = "Bayes Factor\n(>1 means support for Alternative Hypothesis",
    title = "Bayes Factor for various proposed levels of slowdown",
    subtitle = "Based on all series up to 2011-18"
  ) +
  guides(fill = FALSE) +
  scale_x_continuous(breaks = seq(0, 100, by = 10))

## Warning: Using alpha for a discrete variable is not advised.

For all populations except males in Northern Ireland, the addition of the 2018 single year life expectancy data led to sizeable increases in the empirical support for the belief that there has been a slowdown in life expectancy after 2010; this is seen by noting how much higher the bold line, which incorporates the 2018 data, is than the fainter lines representing cumulative data based on shorter series of observations. For most of these populations, the peak of the bold line is to the left of peaks based on earlier series, meaning not only did the 2018 observations increase the strength of evidence supporting belief in a slowdown in life expectancy improvements, but also suggested more severe magnitudes of slowdown than the series excluding this most recent observation had indicated. For the UK as a whole, the addition of the life expectancy data for 2018 suggested an overall slowdown of around 60% was most likely, compared with a most likely magnitude of slowdown of around 50% based on data up to 2017. For each of these populations, what does the Bayes Factor maximise at?

bf_uk_nations %>% 
   filter(period == "2011-18") %>% 
   mutate(perc = 100 * perc) %>%
   mutate(
    population = factor(population, levels = rev(c("United Kingdom", "Great Britain", "England & Wales", "England", "Scotland", "Wales", "Northern Ireland")))
  ) %>% 
  group_by(sex, population) %>% 
  filter(bayes_factor == max(bayes_factor)) %>% 
  ungroup() %>% 
  ggplot(aes(y = population, x = 100 - perc, shape = sex, colour = sex)) + 
  geom_point() + 
  labs(
    x = "Percentage decline from 1980-2011 levels",
    y = "Population", 
    title = "Estimated percentage decline in life expectancy improvement rates over 2011-2018 compared with 1981-2010"
  ) +
  lims(x = c(0, 100))

And as a table

bf_uk_nations %>% 
   filter(period == "2011-18") %>% 
   mutate(perc = 100 * perc) %>%
   mutate(
    population = factor(population, levels = rev(c("United Kingdom", "Great Britain", "England & Wales", "England", "Scotland", "Wales", "Northern Ireland")))
  ) %>% 
  group_by(sex, population) %>% 
  filter(bayes_factor == max(bayes_factor)) %>% 
  ungroup() %>% 
  select(population, sex, perc, bayes_factor) %>% 
  mutate(perc = 100 - perc)

In the UK as a whole, it is most likely that life expectancy improvement rates have slowed down by 62% for females, and 59% for males. This is made up of a 60% (females) and 59% (males) slowdown in England, a 72% (females) and 56% (males) slowdown in Scotland, a 59% (females) and 29% (males) slowdown in Northern Ireland, and an estimated 77% (females) and 83% (males) slowdown in Wales. With the exception of males in Northern Ireland, rates of slowdown are therefore similar across UK nations, and generally slightly more severe for females than males.

Some important points:

This approach means that the process of updating beliefs about the extent and evidence for a slowdown in life expectancy gains can be made formally rather than informally.
The Bayes Factor schedules can be recalculated whenever a new data release becomes available. This means that updated schedules can be produced within minutes of the release of official statistics. The commitment to do this each each new release, and to publish updated estimates of support for slowdown, should be made before such data are released.
The tendency within UK populations has been for the rate of slowdown to be increasing over time, rather than to shift suddenly from one rate to another. If this continues then the proposed slowdown percentage that maximises the bayes factor will continue to shift further to the left with additional years’ data, and could be maximised at a negative value (i.e. declining life expectancy rather than slowing improvement) if this tendency continues.

Scrapbook

International comparison

Let’s look at how the UK compares with a small selection of other nations. For this international comparison, data from the [Human Mortality Database] will be used. These data are not as up-to-date as those produced by the ONS in their single year lifetables, and are more out-of-date for some countries than others.

How has life expectancy changed in each of these populations since 1980?

hmd_e0 %>% 
  filter(sex == "total") %>% 
  filter(country %in% c("CAN", "USA", "DEUTNP", "NLD", "FRATNP", "GBR_NP", "JPN", "RUS", "NOR", "AUS", "FIN", "ITA")) %>% 
  group_by(country) %>% 
  arrange(year) %>% 
  mutate(ch_e0 = e0 - lag(e0)) %>% 
  filter(year >= 1980) %>% 
  ungroup() %>% 
  mutate(ch_e0 = 52.25 * ch_e0) %>% 
  ggplot(aes(x = year, y = ch_e0)) +
  stat_smooth() +
  geom_point() + geom_line() + 
  facet_wrap(~country, scales = "free_y") + 
  geom_hline(yintercept = 0) +
  labs(
    x = "Year", y = "Change in life expectancy from previous year (weeks)",
    title = "Annual change in period life expectancy, selected high income countries",
    caption = "Source: HMD"
  )

## `geom_smooth()` using method = 'loess' and formula 'y ~ x'

## Warning: Removed 1 rows containing non-finite values (stat_smooth).

## Warning: Removed 1 rows containing missing values (geom_point).

ggsave(here("figures", "all_countries_hmd.png"), height = 20, width = 28, units = "cm", dpi = 300)

## `geom_smooth()` using method = 'loess' and formula 'y ~ x'

## Warning: Removed 1 rows containing non-finite values (stat_smooth).

## Warning: Removed 1 rows containing missing values (geom_point).

This gives some pause for thought. Countries that have seen a slowdown in life expectancy improvement in recent years include:

The USA (most severe)
The UK
The Netherlands
France
Canada
Australia
Germany (least severe)

Note a difference scale is used for each country, mainly due to the high annual variation in Russia, which saw a sudden decline in life expectancy, of around four years in the years following the collapse of the USSR. With the exception of Russia, and France and Italy in 2003-4 (discussed next), the scales for other populations are quite similar. Note that Italy’s population data submitted to the HMD are less recent than for the other European countries, and more up-to-date data may also suggest a slowdown in Italy as well.

Note also a very high annual increase in life expectancy from 2003-2004, in the following countries:

France
Italy
the UK (to a lesser extent)
Norway (to a lesser extent)
The USA (to a lesser extent)

In France this gain was of around 40 weeks. This appears to correspond to an exceptionally mild winter in 2003-2004, apparently the mildest in around 50 years according to this paper. It is more than conceivable that this phenomena will lead to some mortality displacement in subsequent years, though I expect any such effect to be transient and not to be sufficient to explain the long-term slowdown observed in the first list of countries above.

Within Murphy’s LSE Working Paper on mortality trends, breakpoint analysis was performed for a number of high income countries. This identified a breakpoint of around 2010 in the UK, but around 2005 in some other European countries. (See Figure 4 or report) Further descriptive statistics breaking down mortality change rates by whether the deaths were attributed to cardiovascular disease (i.e. CVD mortality, non-CVD mortality, and total mortality: See Figure 14) also indicated a turning point in cardiovascular disease death rates from 2005 onwards, in France, the Netherlands, and the UK. To the extent that CVD is seasonally patterned and a predominant cause of mortality, and that an outlier value could lead the breakpoint analysis algorithm to split the series into before and after the outlier, it appears conceivable that the finding of a turning point in mortality of around 2005, as identified in a number of European populations, could be in part an artefact of the mild 2003-4 winter. (However, as Figure 14 is not based on a breakpoint analysis, but SDRs alone, and shows that CVD SDR improvement rates have continued to decline for many years post 2005, artefact alone is unlikely to be the main explanation for the series.)

Bayes Factor Slowdown using ONS data

Prep preamble

Introduction/structure

1 Annual rates of change internationally

1.1 Data

1.2 Results

1.2.1 HMD Average change in \(e_0\) by decade

1.2.1.1 Figure of HMD Average change in \(e_0\) by decade

1.2.1.2 Table of HMD Average change in \(e_0\) by decade

1.2.1.3 Annual change in slow gainers since 1990

2 Annual change rates in life expectancy in the UK as a whole and UK nations or groups of nations + change point analyses

2.1 Data

2.1.1 Data preparation

2.2 Analysis

2.2.1 Change in life expectancy in UK nations and groups of nations

2.2.1.1 Figure of change in life expectancy in UK nations and groups of nations

2.2.2 Average change by decade

2.2.3 Change in life expectancy in mutually exclusive UK nations

2.2.3.1 Change in life expectancy in mutually exclusive UK nations - faceted

2.2.3.2 Change in life expectancy in mutually exclusive UK nations - overlaid

2.2.4 Breakpoint analysis

2.2.4.1 Breakpoint figure

2.2.4.2 Breakpoint table

2.2.4.3 Breakpoint figure - mutually exclusive UK nations

2.2.4.2 Breakpoint table

2.2.4.2 Effect of different random number seeds on breakpoint

3 ONS life expectancy projections

3.1 Data

Scrapbook

International comparison